# Definition and implementation of the Trace class.

package require Iexpect
package require Iarray

class Trace {

	common eNumber "\[-\]?\[0-9.\]+"
	common eUpScale 6

	proc tiltBBox {bbox} {
		set sum [expr ([lindex $bbox 0] + [lindex $bbox 1] + [lindex $bbox 2] + [lindex $bbox 3]) / 2]
		list [expr $sum - [lindex $bbox 3]] [expr $sum - [lindex $bbox 2]]
			[expr $sum - [lindex $bbox 1]] [expr $sum - [lindex $bbox 0]]
	}
	proc scaleBBox {bbox xScale yScale} {
		list [expr [lindex $bbox [expr ($xScale > 0) ? 0 : 2]] * $xScale] [expr [lindex $bbox [expr ($yScale > 0) ? 1 : 3]] * $yScale]
			[expr [lindex $bbox [expr ($xScale < 0) ? 0 : 2]] * $xScale] [expr [lindex $bbox [expr ($yScale < 0) ? 1 : 3]] * $yScale]
	}
	proc translateBBox {bbox dx dy} {
		list [expr [lindex $bbox 0] + $dx] [expr [lindex $bbox 1] + $dy]
			[expr [lindex $bbox 2] + $dx] [expr [lindex $bbox 3] + $dy]
	}

	constructor {fileSpec} {
		set iOutlines [iarray::Sequence #auto]
		read $fileSpec
	}
	destructor {
		delete object $iOutlines
	}

	protected method read {fileSpec}

	method getColorIds {} {$iOutlines names}
	method getColorValue {colorId} {lindex $iColors $colorId}
	method getOutline {colorId} {$iOutlines of $colorId}

	method getUpScale {} {return $eUpScale}
	method getBoundingBox {scaledUp xMirrored yMirrored tilted}

	method close {upperLeftCornerColorId} {
		foreach {colorId outline} [$iOutlines get] { $outline close [expr $colorId == $upperLeftCornerColorId] }
	}
	method xMirror {} {
		foreach {colorId outline} [$iOutlines get] { $outline xMirror }
	}
	method yMirror {} {
		foreach {colorId outline} [$iOutlines get] { $outline yMirror }
	}
	method tilt {} {
		set iBBox [tiltBBox $iBBox]
		foreach {colorId outline} [$iOutlines get] { $outline tilt }
	}
	method scale {xScale yScale} {
		set iBBox [scaleBBox $iBBox $xScale $yScale]
		foreach {colorId outline} [$iOutlines get] { $outline scale $xScale $yScale }
	}
	method translate {dx dy} {
		set iBBox [translateBBox $iBBox $dx $dy]
		foreach {colorId outline} [$iOutlines get] { $outline translate $dx $dy }
	}

	protected method scaleUp {pt} {list [expr round([lindex $pt 0] * $eUpScale)] [expr round([lindex $pt 1] * $eUpScale)]}
	protected method scaleDown {pt} {list [expr [lindex $pt 0] / $eUpScale] [expr [lindex $pt 1] / $eUpScale]}
	protected method xMirror {pt} {list [expr [lindex $iBBox 2] + [lindex $iBBox 0] - [lindex $pt 0]] [lindex $pt 1]}
	protected method yMirror {pt} {list [lindex $pt 0] [expr [lindex $iBBox 3] + [lindex $iBBox 1] - [lindex $pt 1]]}
	
	variable iOutlines
	variable iColors {}
	variable iBBox {}
}

body Trace::read {fileSpec} {
	set I [iexpect::Expect #auto -white -file $fileSpec]

	set colorId 0
	set curves {}
	set curving 0

	$I expect line "^%%BoundingBox: ?($eNumber $eNumber $eNumber $eNumber)$" {
		set iBBox [eval list [scaleUp [lrange [$I get match 1] 0 1]] [scaleUp [lrange [$I get match 1] 2 3]]] 
		$I continue
	} "^($eNumber $eNumber $eNumber $eNumber) \[kK\]$" {
		assert {!$curving} "Color change inside curve"
		if {[llength $curves] > 0} {
			if [$iOutlines has $colorId] {
				[$iOutlines of $colorId] acquire $curves
			} else {
				$iOutlines set $colorId [iarray::code [Outline #auto $iBBox $eUpScale $curves]]
			}
		}
		set color [$I get match 1]
		set colorId [expr [lsearch $iColors $color] + 1]
		if {$colorId == 0} {
			lappend iColors $color
			set colorId [llength $iColors] 
		}
		set curves {}
		$I continue
	} "^($eNumber $eNumber) m$" {
		assert {!$curving} "moveto inside curve"
		set curving 1
		set curve [iarray::code [Curve #auto [scaleUp [$I get match 1]]]]
		$I continue
	} "^($eNumber $eNumber) l$" {
		assert $curving "lineto outside curve"
		$curve lineTo [scaleUp [$I get match 1]]
		$I continue
	} "^($eNumber $eNumber) ($eNumber $eNumber) ($eNumber $eNumber) c$" {
		assert $curving "curveto outside curve"
		$curve curveTo [scaleUp [$I get match 1]] [scaleUp [$I get match 2]] [scaleUp [$I get match 3]]
		$I continue
	} "^\[Sf\]$" {
		assert $curving "stroke outside curve"
		set curving 0
		lappend curves $curve
		$I continue
	} default {
		$I continue
	}

	if {[llength $curves] > 0} {
		if [$iOutlines has $colorId] {
			[$iOutlines of $colorId] acquire $curves
		} else {
			$iOutlines set $colorId [iarray::code [Outline #auto $iBBox $eUpScale $curves]]
		}
	}
	
	delete object $I
}

body Trace::summarize {} {
	set idx 0
	foreach color $iColors {
		puts "[incr idx]: CMYK = $color - #curves = [llength $iOutlines($idx)]" 
	}
}

body Trace::detailContents {colorId} {
	assert {($colorId > 0) && ($colorId <= [llength $iColors])} "No outline defined in color $colorId"

	puts "$colorId: CMYK = [lindex $iColors [expr $colorId - 1]] - #curves = [llength $iOutlines($colorId)]"
	foreach curve $iOutlines($colorId) {
		set bbox [$curve getBBox]
		set ul [scaleDown [yMirror "[lindex $bbox 0] [lindex $bbox 3]"]]
		set lr [scaleDown [yMirror "[lindex $bbox 2] [lindex $bbox 1]"]]
		puts "Curve from [scaleDown [yMirror [$curve getStartPoint]]] to [scaleDown [yMirror [$curve getEndPoint]]] between $ul and $lr"
	}
}

body Trace::getBoundingBox {} {
	return "[scaleDown [lrange $iBBox 0 1]] [scaleDown [lrange $iBBox 2 3]]"
}

body Trace::writeContents {colorId fileId updates} {
	set params [iarray::Array #auto $updates]
	switch [$params of operation] "fill" {
		writeFillContents $colorId $fileId [$params on operator S] [$params on offset "0 0"]
	} "stroke" {
		writeStrokeContents $colorId $fileId [$params on operator S] [$params on offset "0 0"]
	} default {
		writePointContents $colorId $fileId [$params on operator S] [$params on offset "0 0"] [$params on format raw] [$params on identifiers {}]
	}
	delete object $params
}

body Trace::writeFillContents {colorId fileId operator offset} {
	assert {($colorId > 0) && ($colorId <= [llength $iColors])} "No outline defined in color $colorId"

	set allCurves [close $iOutlines($colorId) \
		$iBBox [expr $eBBoxDist * $eUpScale] [expr $iUpperLeftCornerColorId == $colorId]]
	
	set looseCurves [lindex [lindex $allCurves 1] 1]
	if {[llength $looseCurves] > 0} {
		inform "Discarding [llength $looseCurves] loose curves"
		foreach curve $looseCurves {
			inform "From [scaleDown [yMirror [$curve getStartPoint]]] to [scaleDown [yMirror [$curve getEndPoint]]]"
			delete object $curve
		} 
	}
	set iOutlines($colorId) [concat [lindex [lindex $allCurves 1] 0] [lindex $allCurves 0]]

	puts $fileId "s"
	if {([lindex $offset 0] != 0) || ([lindex $offset 1] != 0)} {
		puts $fileId "$offset t"
	} 
	foreach curve $iOutlines($colorId) {
		puts $fileId "[$curve getStartPoint] m"
		$curve forEachPiece piece {
			puts $fileId "$piece l"
		} {
			puts $fileId "[eval concat $piece] c"
		}
		puts $fileId $operator
	}
	puts $fileId "r"
}

body Trace::writeStrokeContents {colorId fileId operator offset} {
	assert {($colorId > 0) && ($colorId <= [llength $iColors])} "No outline defined in color $colorId"

	extend $iOutlines($colorId) $iBBox [expr $eBBoxDist * $eUpScale]

	puts $fileId "s"
	if {([lindex $offset 0] != 0) || ([lindex $offset 1] != 0)} {
		puts $fileId "$offset t"
	} 
	puts $fileId "1 $eUpScale div dup x"
	foreach curve $iOutlines($colorId) {
		puts $fileId "[$curve getStartPoint] m"
		$curve forEachPiece piece {
			puts $fileId "$piece l"
		} {
			puts $fileId "[eval concat $piece] c"
		}
		puts $fileId $operator
	}
	puts $fileId "r"
}

body Trace::writePointContents {colorId fileId operator offset format identifiers} {
	assert {($colorId > 0) && ($colorId <= [llength $iColors])} "No outline defined in color $colorId"

	if {![llength $identifiers]} { 
		foreach curve $iOutlines($colorId) {
			set bbox [$curve getBBox]
			puts $fileId "[expr ([lindex $bbox 0] + [lindex $bbox 2]) / 2 / $eUpScale + [lindex $offset 0]]\
				[expr ([lindex $bbox 1] + [lindex $bbox 3]) / 2 / $eUpScale + [lindex $offset 1]] $operator"
		}
	} else {
		assert {[llength $identifiers] >= [llength $iOutlines($colorId)]} "Not enough names listed. Expected [llength $iOutlines($colorId)], got [llength $identifiers]."
		assert {[llength $identifiers] <= [llength $iOutlines($colorId)]} "Too many names listed. Expected [llength $iOutlines($colorId)], got [llength $identifiers]."

		switch $format string {
			set identifiers [regsub -all "\[^ \]+" $identifiers "(&)"]
		} name {
			set identifiers [regsub -all "\[^ \]+" $identifiers "/&"]
		}

		foreach name $identifiers curve $iOutlines($colorId) {
			set bbox [$curve getBBox]
			puts $fileId "[expr ([lindex $bbox 0] + [lindex $bbox 2]) / 2 / $eUpScale + [lindex $offset 0]]\
				[expr ([lindex $bbox 1] + [lindex $bbox 3]) / 2 / $eUpScale + [lindex $offset 1]] $name $operator"
		}
	}
}
